;;########################################################################
;; tranobj2.lsp
;; contains code to implement prototype transformation objects
;; Copyright (c) 1991-95 by Forrest W. Young
;;########################################################################

;;------------------------------------------------------------------------
;;absolute value object proto
;;------------------------------------------------------------------------

(defproto absval-transf-object-proto '() () transf-object-proto)

(defmeth absval-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth absval-transf-object-proto :options () t)

(defmeth absval-transf-object-proto :analysis ()
  (let* (
         (data-matrix (send self :active-data-matrix '(numeric)))
         (size (reverse (array-dimensions data-matrix)))
          (absval-data (map-elements #'function-with-missing #'abs (column-list data-matrix)))
         	;; modified by PV to deal with missing data 30.7.98
         (absval-data-matrix 
               (transpose (matrix size (combine absval-data))))
         )
    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :title     (concatenate 'string "Abs-" (send self :title))
          :labels    (send current-data :active-labels) 
          :data      (combine absval-data-matrix)
          :variables (send self :active-variables '(numeric))
          :freq      (send self :freq)
          :row-label (first (send self :freq-way-names))
          :column-label (second (send self :freq-way-names))
          :types     (send self :active-types     '(numeric)))))

(defun absolute-value 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Abs")
   (title      nil)
   )
  (send absval-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;normal scores object proto
;;------------------------------------------------------------------------

(defproto nscores-transf-object-proto '() () transf-object-proto)

(defmeth nscores-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth nscores-transf-object-proto :options () t)

(defmeth nscores-transf-object-proto :analysis ()
  (let* (
         (data-matrix (send self :active-data-matrix '(numeric)))
         (size (reverse (array-dimensions data-matrix)))
         (nscores-data (map-elements #'function-with-missing #'nscores (column-list data-matrix)))
         	;; modified by PV to deal with missing data 30.7.98
         (nscores-data-matrix 
               (transpose (matrix size (combine nscores-data))))
         )
    (data (send self :name)
          :created   (- (send *desktop* :num-icons) 1)
          :title     (concatenate 'string "NScores-" (send self :title))
          :labels    (send current-data :active-labels) 
          :data      (combine nscores-data-matrix)
          :freq      (send self :freq)
          :row-label (first (send self :freq-way-names))
          :column-label (second (send self :freq-way-names))
          :variables (send self :active-variables '(numeric))
          :types     (send self :active-types     '(numeric)))))

(defun normal-scores 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "NScrs")
   (title      nil)
   )
  (send nscores-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;exponential object proto
;;------------------------------------------------------------------------

(defproto exponential-transf-object-proto '(choice) () transf-object-proto)

(defmeth exponential-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth exponential-transf-object-proto :choice (&optional (value nil set))
    (if set (setf (slot-value  'choice) value))
    (slot-value 'choice))

(defmeth exponential-transf-object-proto :options () 
  (send self :choice
        (choose-item-dialog "Choose Exponent(ial) Function" 
                            '("Natural Exponential (base e)" 
                              "Exponential - base x"
                              "Square Root (power 1/2)" "Square (power 2)"
                              "R'th Root (power 1/r)" "R'th Power (power r)"))))

(defmeth exponential-transf-object-proto :analysis ()
  (let* (
         (data-matrix (send self :active-data-matrix '(numeric)))
         (size (reverse (array-dimensions data-matrix)))
         (ncol (first size))
         (choice (send self :choice))
         (param nil)
         (string nil)
         (exp-data nil)
         (exp-data-matrix nil))
   (when choice 
          (cond
            ((= choice 0) 
             (setf exp-data (map-elements #'function-with-missing #'exp (column-list data-matrix)))
             (setf string "NatExp"))
            ((= choice 1) 
             (setf param (get-value-dialog "Specify Base of Exponential"
                                           :initial 10))
             (setf exp-data (map-elements #'function-with-missing #'exp (column-list data-matrix) (repeat (list param) ncol)))
         	;; modified by PV to deal with missing data 30.7.98
                                    
             (setf string "XExp"))
            ((= choice 2)
             (setf exp-data (map-elements #'function-with-missing #'sqrt (column-list data-matrix)))
             (setf string "Sqrt"))
            ((= choice 3)
             (setf param (list 2))
             (setf exp-data (map-elements #'function-with-missing #'^ (column-list data-matrix) (repeat (list param) ncol)))
	;; modified by PV to deal with missing data 30.7.98
             (setf string "Sqre"))
            ((= choice 5)
             (setf param (get-value-dialog "Specify Power" :initial 3))
             (setf exp-data (map-elements #'function-with-missing #'^ (column-list data-matrix) (repeat (list param) ncol)))
	;; modified by PV to deal with missing data 30.7.98
                                    
             (setf string "PowR"))
            ((= choice 4)
             (setf param (get-value-dialog "Specify Root" :initial 3))
             (setf exp-data (map-elements #'function-with-missing #'^ (column-list data-matrix) (repeat (list (/ param)) ncol)))
	;; modified by PV to deal with missing data 30.7.98
             (setf string "RootR"))
            )
          (setf exp-data-matrix 
                (transpose (matrix size (combine exp-data))))
          (data (strcat string "-" (send current-data :name))
                :created   (- (send *desktop* :num-icons) 1)
                :title     (strcat string "-" (send self :title))
                :labels    (send current-data :active-labels) 
                :data      (combine exp-data-matrix)
                :freq      (send self :freq)
                :row-label (first (send self :freq-way-names))
                :column-label (second (send self :freq-way-names))
                :variables (send self :active-variables '(numeric))
                :types     (send self :active-types     '(numeric))))))

(defun exponential 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Exp")
   (title      nil)
   )
  (send exponential-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;logarithm object proto
;;------------------------------------------------------------------------

(defproto logarithm-transf-object-proto '(choice) ()
  transf-object-proto)

(defmeth logarithm-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth logarithm-transf-object-proto :choice (&optional (value nil set))
    (if set (setf (slot-value  'choice) value))
    (slot-value 'choice))

(defmeth logarithm-transf-object-proto :options () 
  (send self :choice
        (choose-item-dialog "Choose Logarithm Function" 
                            '("Natural (base e)" "Log-x (base x)"))))

(defmeth logarithm-transf-object-proto :analysis ()
  (if (<= (min (non-missing (combine (send self :active-data-matrix '(numeric))))) 0)
      (error-message "Cannot take logarithms of non-positive numbers.")
          ;; modified by PV to deal with missing data 30.7.98
      (let* ((data-matrix (send self :active-data-matrix '(numeric)))
             (size (reverse (array-dimensions data-matrix)))
             (ncol (first size))
             (choice (send self :choice))
             (base nil)
             (string nil)
             (log-data nil)
             (log-data-matrix nil))
        (when choice 
              (cond
                ((= choice 0) 
                 (setf log-data (map-elements #'function-with-missing #'log (column-list data-matrix)))
                 (setf string "NatLog"))
                ((= choice 1) 
                 (setf base (get-value-dialog "Specify Base of Logs"
                                              :initial 10))
                 (setf log-data 
                       (map-elements #'function-with-missing #'log (column-list data-matrix) (repeat (list base) ncol)))
		;; modified by PV to deal with missing data 30.7.98
                 (setf string "XLog")))
              (setf log-data-matrix 
                    (transpose (matrix size (combine log-data))))
              (data (strcat string "-" (send current-data :name))
                    :created   (- (send *desktop* :num-icons) 1)
                    :title     (strcat string "-" (send self :title))
                    :labels    (send current-data :active-labels) 
                    :data      (combine log-data-matrix)
                    :freq      (send self :freq)
                    :row-label (first (send self :freq-way-names))
                    :column-label (second (send self :freq-way-names))
                    :variables (send self :active-variables '(numeric))
                    :types     (send self :active-types     '(numeric)))))))

(defun logarithm 
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Log")
   (title      nil)
   )
  (send logarithm-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;rounding object proto
;;------------------------------------------------------------------------

(defproto rounding-transf-object-proto '(choice) () transf-object-proto)

(defmeth rounding-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth rounding-transf-object-proto :choice (&optional (value nil set))
    (if set (setf (slot-value  'choice) value))
    (slot-value 'choice))

(defmeth rounding-transf-object-proto :options ()
  (send self :choice
        (choose-item-dialog "Choose Rounding Function" 
                            '("Round (to nearest integer)" "Ceiling (round up)" "Floor (round down)" "Truncate (round toward zero)"))))

(defmeth rounding-transf-object-proto :analysis ()
  (let* ((data-matrix (send self :active-data-matrix '(numeric)))
         (size (reverse (array-dimensions data-matrix)))
         (choice (send self :choice))
         (string nil)
         (rounding-data nil)
         (rounding-data-matrix nil))
    (when choice 
          (cond
           ((= choice 0) 
             (setf rounding-data (map-elements #'function-with-missing #'round (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "Rnd"))
            ((= choice 1) 
             (setf rounding-data (map-elements #'function-with-missing #'ceiling (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "Ceil"))
            ((= choice 2) 
             (setf rounding-data (map-elements #'function-with-missing #'floor (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "Flr"))
            ((= choice 3) 
             (setf rounding-data (map-elements #'function-with-missing #'truncate (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "Trun"))
            )
          (setf rounding-data-matrix 
                (transpose (matrix size (combine rounding-data))))
          (data (strcat string "-" (send current-data :name))
                :created   (- (send *desktop* :num-icons) 1)
                :title     (strcat string "-" (send self :title))
                :labels    (send current-data :active-labels) 
                :data      (combine rounding-data-matrix)
                :freq      (send self :freq)
                :row-label (first (send self :freq-way-names))
                :column-label (second (send self :freq-way-names))
                :variables (send self :active-variables '(numeric))
                :types     (send self :active-types     '(numeric))))))

(defun rounding
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Round")
   (title      nil)
   )
  (send rounding-transf-object-proto :new 9 data title name dialog))


;;------------------------------------------------------------------------
;;trigonometric object proto
;;------------------------------------------------------------------------

(defproto trig-transf-object-proto '(choice) () transf-object-proto)

(defmeth trig-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth trig-transf-object-proto :choice (&optional (value nil set))
    (if set (setf (slot-value  'choice) value))
    (slot-value 'choice))

(defmeth trig-transf-object-proto :options ()
  (send self :choice
        (choose-item-dialog "Choose Trigonometric Function" 
                            '("Sine" "Cosine" "Tangent" 
                              "Arc Sine" "Arc Cosine" "Arc Tangent"))))

(defmeth trig-transf-object-proto :analysis ()
  (let* ((data-matrix (send self :active-data-matrix '(numeric)))
         (size (reverse (array-dimensions data-matrix)))
         (choice (send self :choice))
         (string nil)
         (trig-data nil)
         (trig-data-matrix nil))
 (when choice
          (cond
            ((= choice 0)              
             (setf trig-data (map-elements #'function-with-missing #'sin (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "Sine"))
            ((= choice 1) 
             (setf trig-data (map-elements #'function-with-missing #'cos (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "Cos"))
            ((= choice 2) 
             (setf trig-data (map-elements #'function-with-missing #'tan (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "Tan"))
            ((= choice 3) 
             (setf trig-data (map-elements #'function-with-missing #'asin (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "ASine"))
            ((= choice 4) 
             (setf trig-data (map-elements #'function-with-missing #'acos (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "ACos"))
            ((= choice 5) 
             (setf trig-data (map-elements #'function-with-missing #'atan (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (setf string "ATan")))
          (setf trig-data-matrix 
                (transpose (matrix size (combine trig-data))))
          (data (strcat string "-" (send current-data :name))
                :created   (- (send *desktop* :num-icons) 1)
                :title     (strcat string "-" (send self :title))
                :labels    (send current-data :active-labels) 
                :data      (combine trig-data-matrix)
                :freq      (send self :freq)
                :row-label (first (send self :freq-way-names))
                :column-label (second (send self :freq-way-names))
                :variables (send self :active-variables '(numeric))
                :types     (send self :active-types     '(numeric))))))

(defun trigonometric
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Trig")
   (title      nil)
   )
  (send trig-transf-object-proto :new 9 data title name dialog))

;;------------------------------------------------------------------------
;;reciprocol object proto
;;------------------------------------------------------------------------

(defproto reciprocal-transf-object-proto '() () transf-object-proto)

(defmeth reciprocal-transf-object-proto :isnew (&rest args)
  (apply #'call-next-method args))

(defmeth reciprocal-transf-object-proto :options () t)

(defmeth reciprocal-transf-object-proto :analysis ()
  (if (member 0 (combine (send self :active-data-matrix '(numeric))))
      (error-message "Cannot take reciprocal of data containing zeros.")
      (let* ((data-matrix (send self :active-data-matrix '(numeric)))
             (size (reverse (array-dimensions data-matrix)))
             (reciprocal-data (map-elements #'function-with-missing #'/ (column-list data-matrix)))
		;; modified by PV to deal with missing data 30.7.98
             (reciprocal-data-matrix 
              (transpose (matrix size (combine reciprocal-data))))
             )
        (data (send self :name)
              :created   (- (send *desktop* :num-icons) 1)
              :title     (concatenate 'string "Recip-" (send self :title))
              :labels    (send current-data :active-labels) 
              :data      (combine reciprocal-data-matrix)
              :freq      (send self :freq)
              :row-label (first (send self :freq-way-names))
              :column-label (second (send self :freq-way-names))
              :variables (send self :active-variables '(numeric))
              :types     (send self :active-types     '(numeric))))))

(defun reciprocal
  (&key 
   (data       current-data)
   (dialog     nil)
   (name       "Recip")
   (title      nil)
   )
  (send reciprocal-transf-object-proto :new 9 data title name dialog))


;;------------------------------------------------------------------------
;;user-defined transformation
;;------------------------------------------------------------------------

(defmeth vista-system-object-proto :user-defined-transformation ()
  (user-defined-transformation))

(defun user-defined-transformation ()
  (disable-container)
  (let* ((heading (send text-item-proto :new "Choose a Program Entry Tool:"))
         (choices (send choice-item-proto :new (list  "Listener" "Lisp Editor")))
         (help    (send button-item-proto :new "Help"
                        :action #'(lambda () (send self :help))))
         (ok      (send button-item-proto :new "Choose"
                        :action #'(lambda () (send self :ok))))
         (dialog  (send dialog-proto :new 
                        (list heading (list  choices (list help ok)))
                        :title "User Defined Transformation"))
         )
    (defmeth ok      :ok () 
      (eval (select (list '(xlispstat-window :viva nil) ;'(user-listener)
                          '(system (strcat *default-path* "lspedit.exe"))
                          ) 
                    (send choices :value)))
      (send dialog :close))
    (defmeth help :help () (plot-help-window (strcat "Help: User Defined Transformation"))

      (paste-plot-help (format nil "There are two tools available to you for defining your own variable transformation program: The Listener and the Lisp Editor. With these tools you can enter statements in ViSta's two progamming languages: Lisp and ViVa. The programs you write can transform variables in the data objects that have been defined.")) 

(paste-plot-help (format nil "~2%THE LISTENER AND THE EDITOR~2%The Listener lets you enter your program interactively, each statement being run when you type return."))

(paste-plot-help (format nil "~2%The Lisp Editor helps you create a program which can be run when you wish, rather than when every line is entered. The program can also be saved as needed. To run the program, use the Editor's Eval menu item, or save the program in a file and load it using ViSta's Load Edit menu item."))

(paste-plot-help (format nil "~2%The Listener is good for trying out individual statements, whereas the Editor is best for creating programs (groups of statements). The Listener gives you instant results, the Editor is for longer term development.  Often it is best to use both tools simultaneously, since it can be useful to use the Listener to test statements in the program and the Editor to construct and save the program."))

(paste-plot-help (format nil "~2%LISP AND VIVA~2%Lisp and ViVa are the two programming languages that you can use to transform your data. These languages are discussed in other help items available in the Help menu. Note, however, that Lisp can be used with both the Listener and the Editor, whereas ViVa can only be used with the Listener."))

(paste-plot-help (format nil "~2%DATA OBJECTS AND VARIABLES~2%It is important to note that the data objects which have been defined during the analysis session are available to your program, and that the variables in these data objects are available to be transformed by your program. Consequently, when the Listener is choosen, it informs you of the data objects and variables that are currently available. The current data object (the one whose icon is high-lighted) and its variables are represented by the following symbols:~%$ is the current data object~%$vars is the list of variables in $"))

(paste-plot-help (format nil "~2%In addition, the following symbols represent the other data objects and their variables (the names are constructed from the data object name and the variable name):~%$data is the list of all the data objects~%$data$vars is the list of all variables in all data objects"))
(show-plot-help)
      )))

(setf *user-listener* nil)







(provide "tranobj2")
